home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 5_2007-2008.ISO / data / Zips / MyConnecti2048092162007.psc / Class Modules / MyReader.cls < prev   
Text File  |  2007-02-16  |  12KB  |  299 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "MyReader"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. 'Written by Mehmet Gⁿrevin :)
  15.  
  16. Option Explicit
  17.  
  18. Private Const SIZE_OF_CHAR = 4
  19.  
  20. Private Declare Function mysql_store_result Lib "libmysql.dll" (ByVal hMysql As Long) As Long
  21. Private Declare Function mysql_free_result Lib "libmysql.dll" (ByVal lResultPointer As Long) As Long
  22. Private Declare Function mysql_fetch_row Lib "libmysql.dll" (ByVal lResultPointer As Long) As Long                                              'Return the row struct pointer
  23. Private Declare Function mysql_field_count Lib "libmysql.dll" (ByVal hMysql As Long) As Long
  24. Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
  25. Private Declare Function lstrlen Lib "kernel32.dll" Alias "lstrlenA" (ByVal lpString As Long) As Long
  26. Private Declare Function mysql_fetch_field Lib "libmysql.dll" (ByVal lResultPointer As Long) As Long                                            'Return the field struct pointer
  27. Private Declare Function mysql_fetch_lengths Lib "libmysql.dll" (ByVal lResultPointer As Long) As Long                              'returns * unsigned long
  28. Private Declare Function mysql_num_rows Lib "libmysql.dll" (ByVal lResultPointer As Long) As Long                                               'Return the 8 bit lenght pointer, myulonglong
  29.  
  30. Private lResult                         As Long
  31. Private mCnnPtr                         As Long
  32. Private lRes                            As Long
  33. Private bClosed                         As Boolean
  34. Private mCNN                            As MyConnection
  35.  
  36. Private Values()                        As MyField
  37.  
  38. Public Property Set CnnObject(ByRef lObject As MyConnection)
  39.     Set mCNN = lObject
  40. End Property
  41.  
  42. Public Property Get ResultPointer() As Long
  43.     ResultPointer = lResult
  44. End Property
  45.  
  46. Public Property Let ResultPointer(ByVal Value As Long)
  47.     lResult = Value
  48.     lRes = mysql_store_result(mCnnPtr)
  49.     If lRes Then
  50.         bClosed = False
  51.         
  52.         Dim i As Long
  53.         Dim fType                           As Long
  54.         Dim lRet                            As Long
  55.         Dim fLen                            As Long
  56.         Dim fName                           As Long
  57.         Dim fCount                          As Long
  58.         
  59.         fCount = mysql_field_count(mCnnPtr)
  60.         
  61.         ReDim Values(fCount - 1) As MyField
  62.         
  63.         For i = 0 To fCount - 1
  64.             Set Values(i) = New MyField
  65.         Next i
  66.         
  67.         For i = 1 To fCount
  68.             lRet = mysql_fetch_field(lRes)
  69.             If lRet Then
  70.                 CopyMemory fName, ByVal lRet, 4
  71.                 CopyMemory fLen, ByVal lRet + 28, 4
  72.                 CopyMemory fType, ByVal lRet + 76, 4
  73.             End If
  74.             
  75.             Select Case fType
  76.                 Case 16, 1, 2, 9, 3, 8 '16: BIT, 1:TINYINT, 2:SMALLINT, 9:MEDIUMINT, 3:INT, 8:BIGINT
  77.                     'Long
  78.                     Values(i - 1).FieldType = vbLong
  79.                 Case 4   'FLOAT
  80.                     'Currency
  81.                     Values(i - 1).FieldType = vbCurrency
  82.                 Case 5   'DOUBLE
  83.                     'Double
  84.                     Values(i - 1).FieldType = vbDouble
  85.                 Case 246, 254, 253 '[246:DECIMAL][245:CHAR,BINARY,ENUM,SET][253:VARCHAR , VARBINARY]
  86.                     'String
  87.                     Values(i - 1).FieldType = vbString
  88.                     If fType = 253 Then
  89.                         Values(i - 1).Tag = "Trim"
  90.                     End If
  91.                 Case 10, 12, 7, 11 '10:DATE, 12:DATETIME, 7:TIMSTAMP, 11:TIME
  92.                     'Date
  93.                     Values(i - 1).FieldType = vbDate
  94.                     If fType = 12 Or fType = 7 Then
  95.                         Values(i - 1).Tag = "Date + Time"
  96.                     ElseIf fType = 11 Then
  97.                         Values(i - 1).Tag = "Time"
  98.                     ElseIf fType = 10 Then
  99.                         Values(i - 1).Tag = "Date"
  100.                     End If
  101.                 Case 13  'YEAR
  102.                     'Integer
  103.                     Values(i - 1).FieldType = vbInteger
  104.                 Case 252 'TINYTEXT , TEXT, MEDIUMTEXT, LONGTEXT, TINYBLOB, BLOB, MEDIUMBLOB, LONGBLOB
  105.                     'Byte Array
  106.                     Values(i - 1).FieldType = vbArray
  107.                 Case 255 'GEOMETRY , POINT, LINESTRING, POLYGON, MULTIPOINT, MULTILINESTRING, MULTIPOLYGON, GEOMETRYCOLLECTION
  108.                     'Tan²ms²z
  109.                     Values(i - 1).FieldType = vbNull
  110.             End Select
  111.             
  112.             Values(i - 1).FieldName = Ptr2Str(fName)
  113.             Values(i - 1).FieldLength = fLen
  114.             Values(i - 1).MySQLTypeNumber = fType
  115.             Values(i - 1).Index = i - 1
  116.         Next i
  117.     Else
  118.         Err.Raise vbObjectError, "MyReader:ResultPointer[" & CStr(Value) & "]", "Kaynak:[mysql_store_result]" & vbCrLf & "Bilinmeyen bir hata olu■tu."
  119.     End If
  120. End Property
  121.  
  122. Public Property Get ConnectionPointer() As Long
  123.     ConnectionPointer = mCnnPtr
  124. End Property
  125.  
  126. Public Property Let ConnectionPointer(ByVal Value As Long)
  127.     mCnnPtr = Value
  128. End Property
  129.  
  130. Public Property Get RowCount() As Long
  131.     If bClosed Then
  132.         Err.Raise vbObjectError, "MyReader:Read()", "Nesne kapal²."
  133.         Exit Property
  134.     End If
  135.     
  136.     RowCount = mysql_num_rows(lRes)
  137. End Property
  138.     
  139. Public Property Get GetValue(ByVal Index As Variant) As MyField
  140.     If bClosed Then
  141.         Err.Raise vbObjectError, "MyReader:Read()", "Nesne kapal²."
  142.         Exit Property
  143.     End If
  144.     
  145.     Dim lValue                  As Long
  146.     Dim sValue                  As String
  147.     Dim i                       As Long
  148.     Dim vFlag                   As Boolean
  149.        
  150.     Select Case VarType(Index)
  151.         Case vbSingle, vbByte, vbCurrency, vbDecimal, vbDouble, vbInteger, vbLong
  152.             Set GetValue = Values(Index)
  153.         Case vbString
  154.             For i = 0 To UBound(Values)
  155.                 If Values(i).FieldName = Trim(Index) Then
  156.                     GetValue = Values(i)
  157.                     vFlag = True
  158.                 End If
  159.             Next i
  160.             If Not vFlag Then
  161.                 Err.Raise vbObjectError, "MyReader:GetValue", "[" & Index & "] Alan² Tabloda Bulunamad²..."
  162.             End If
  163.     End Select
  164. End Property
  165.  
  166. Public Function Read() As Boolean
  167.     Dim Row                             As Long
  168.     Dim i                               As Long
  169.     Dim mStr                            As String
  170.     
  171.     If bClosed Then
  172.         Err.Raise vbObjectError, "MyReader:Read()", "Nesne kapal²."
  173.         Exit Function
  174.     End If
  175.     
  176.     Row = mysql_fetch_row(lRes)
  177.     
  178.     If Row Then
  179.         Read = True
  180.         Dim ColCount                As Long
  181.         Dim FieldNames()            As Long
  182.         
  183.         ColCount = mysql_field_count(mCnnPtr)
  184.         ReDim FieldNames(1 To ColCount) As Long
  185.         
  186.         Dim FieldsLenghts()     As Long
  187.         ReDim FieldsLenghts(ColCount) As Long
  188.         
  189.         CopyMemory FieldsLenghts(0), ByVal mysql_fetch_lengths(lRes), (ColCount * SIZE_OF_CHAR)
  190.         
  191.         For i = 1 To ColCount
  192.             CopyMemory FieldNames(1), ByVal Row, SIZE_OF_CHAR * ColCount
  193.             
  194.             Values(i - 1).RealLength = FieldsLenghts(i - 1)
  195.             
  196.             Select Case Values(i - 1).FieldType
  197.                 Case VbVarType.vbLong
  198.                     On Local Error Resume Next
  199.                         Values(i - 1).Value = CLng(Val(Trim(Ptr2Str(FieldNames(i) & " "))))
  200.                     If Err.Number = 6 Then
  201.                         Values(i - 1).Value = Ptr2Str(FieldNames(i) & " ")
  202.                     End If
  203.                     On Local Error GoTo 0
  204.                 Case VbVarType.vbCurrency
  205.                     Values(i - 1).Value = CCur(IIf(Trim(Ptr2Str(FieldNames(i) & " ")) = "", "0" & Mid(CStr((3 / 2)), 2, 1) & "00", Trim(Ptr2Str(FieldNames(i) & " "))))
  206.                 Case VbVarType.vbDouble
  207.                     Values(i - 1).Value = CDbl(Val(Trim(Ptr2Str(FieldNames(i) & " "))))
  208.                 Case VbVarType.vbString
  209.                     If Values(i - 1).Tag = "Trim" Then
  210.                         Values(i - 1).Value = Ptr2Str(FieldNames(i))
  211.                     Else
  212.                         Values(i - 1).Value = Trim(Ptr2Str(FieldNames(i) & " "))
  213.                     End If
  214.                 Case VbVarType.vbInteger
  215.                     Values(i - 1).Value = CInt(Val(Trim(Ptr2Str(FieldNames(i) & " "))))
  216.                 Case VbVarType.vbArray
  217.                     Dim DataLength          As Long
  218.                     Dim Data()              As Byte
  219.  
  220.                     ReDim Data(Values(i - 1).RealLength) As Byte
  221.                     CopyMemory Data(0), ByVal FieldNames(i), Values(i - 1).RealLength
  222.  
  223.                     Values(i - 1).Value = Data
  224.                     Erase Data
  225.                 Case VbVarType.vbDate
  226.                     If Trim(Ptr2Str(FieldNames(i) & " ")) = "" Then
  227.                         Values(i - 1).Value = Null
  228.                     Else
  229.                         mStr = Trim(Ptr2Str(FieldNames(i) & " "))
  230.                         If Values(i - 1).Tag = "Date + Time" Then
  231.                             mStr = Split(mStr, " ")(0)
  232.                             Values(i - 1).Value = CDate(CStr(DateSerial(CInt(Left(mStr, 4)), CInt(Mid(mStr, 6, 2)), CInt(Right(mStr, 2)))) & " " & Split(Trim(Ptr2Str(FieldNames(i) & " ")), " ")(1))
  233.                         ElseIf Values(i - 1).Tag = "Date" Then
  234.                             Values(i - 1).Value = DateSerial(CInt(Left(mStr, 4)), CInt(Mid(mStr, 6, 2)), CInt(Right(mStr, 2)))
  235.                         ElseIf Values(i - 1).Tag = "Time" Then
  236.                             Values(i - 1).Value = CDate(mStr)
  237.                         End If
  238.                     End If
  239.                 Case VbVarType.vbNull
  240.                     DoEvents
  241.             End Select
  242.         Next i
  243.     Else
  244.         Call mysql_free_result(lRes)
  245.         Call mCNN.ExecuteReader("#closereader#")
  246.         bClosed = True
  247.         Read = False
  248.     End If
  249. End Function
  250.  
  251. Public Sub CloseReader()
  252.     If Not bClosed Then
  253.         Call mysql_free_result(lRes)
  254.         bClosed = True
  255.         Call mCNN.ExecuteReader("#closereader#")
  256.     End If
  257. End Sub
  258.  
  259. Private Sub Class_Initialize()
  260.     bClosed = True
  261. End Sub
  262.  
  263. Private Function Ptr2Str(ByVal lPtr As Long) As String
  264.     On Local Error Resume Next
  265.  
  266.     Dim lTmp As Long
  267.  
  268.     If lPtr = 0 Then Exit Function
  269.  
  270.     Dim bTmp As Byte
  271.     Dim aBytes() As Byte
  272.     Dim lChars As Long
  273.  
  274.     lChars = lstrlen(lPtr)
  275.     If lChars = 0 Then Exit Function
  276.  
  277.     ReDim aBytes(1 To lChars) As Byte
  278.     aBytes = String(lChars, " ")
  279.     CopyMemory aBytes(1), ByVal (lPtr), lChars
  280.     Ptr2Str = StrConv(aBytes, vbUnicode)
  281.  
  282.     lTmp = InStr(Ptr2Str, vbNullChar)
  283.     If lTmp > 0 Then
  284.         Ptr2Str = Trim(Left$(Ptr2Str, lTmp - 1))
  285.     Else
  286.         Ptr2Str = Ptr2Str
  287.     End If
  288.  
  289.     Erase aBytes
  290. End Function
  291.  
  292. Private Sub Class_Terminate()
  293.     If Not bClosed Then
  294.         Call mysql_free_result(lRes)
  295.         Call mCNN.ExecuteReader("#closereader#")
  296.     End If
  297. End Sub
  298.  
  299.